home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / parser-errors.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.5 KB  |  80 lines  |  [TEXT/CCL2]
  1. ;;; This contains parser error handlers.  They, in turn, call the
  2. ;;; system error handlers.
  3.  
  4. (define (lexer-error id . msgs)
  5.   (parser-error/common id 'recoverable msgs '#t)
  6.   `#\?)
  7.  
  8. (define (parser-error id . msgs)
  9.   (parser-error/common id 'phase msgs '#f)
  10.   (if (null? *layout-stack*)
  11.       (abort-compilation)
  12.       (recover-to-next-decl *token-stream*)))
  13.  
  14. (define (parser-error/recoverable id . args)
  15.   (parser-error/common id 'recoverable args '#f))
  16.  
  17. (define (parser-error/common id type msgs in-lexer?)
  18.   (let ((place
  19.      (if in-lexer?
  20.          (if (< *current-line* 0)
  21.          (list "Parse error in `~A'" *current-file*)
  22.          (list "Parse error at in file ~A at line ~A, column ~A."
  23.                *current-file* *current-line* *current-col*))
  24.          (let ((tok (cond ((null? *token-args*)
  25.                    *token*)
  26.                   ((null? (cdr *token-args*))
  27.                    (car *token-args*))
  28.                   (else *token-args*)))) ; could be better
  29.            (if (< *current-line* 0)
  30.            (list "Parse error at token ~A in `~A'"
  31.              tok *current-file*)
  32.            (list "Parse error at in file ~A at line ~A, token ~A."
  33.              *current-file* *current-line* tok))))))
  34.     (haskell-error id type (list place msgs))))
  35.  
  36. (define (recover-to-next-decl tokens)
  37.   (cond ((null? tokens)
  38.      (abort-compilation))
  39.     ((eq? (car (car tokens)) 'line)
  40.      (search-layout-stack *layout-stack* tokens (caddr (car tokens))))
  41.     (else (recover-to-next-decl (cdr tokens)))))
  42.  
  43. (define (search-layout-stack layouts tokens column)
  44.   (cond ((null? layouts)
  45.      (abort-compilation))
  46.     ((> column (layout-col (car layouts)))
  47.      (recover-to-next-decl (cdr tokens)))
  48.     ((= column (layout-col (car layouts)))
  49.      (setf *current-col* column)
  50.      (setf *current-line* (cadr (car tokens)))
  51.      (setf *token-stream* (cdr tokens))
  52.      (advance-token)  ; loads up *token*
  53.      ;; *** layout-recovery-fn is not defined anywhere!
  54.      (funcall (layout-recovery-fn (car layouts))))
  55.     (else
  56.      (setf *layout-stack* (cdr *layout-stack*))
  57.      (search-layout-stack (cdr layouts) tokens column))))
  58.  
  59.  
  60. ;;; Here are some very commonly used signalling functions.
  61. ;;; Other (more specific) signalling functions are defined near
  62. ;;; the places where they are called.
  63.  
  64.  
  65. ;;; This is used when a particular token isn't found.
  66.  
  67. (define (signal-missing-token what where)
  68.   (parser-error 'missing-token
  69.         "Missing ~a in ~a." what where))
  70.  
  71.  
  72. ;;; This is used to signal more complicated parse failures involving
  73. ;;; failure to match a nonterminal.
  74.  
  75. (define (signal-invalid-syntax where)
  76.   (parser-error 'invalid-syntax
  77.         "Invalid syntax appears where ~a is expected." where))
  78.  
  79.  
  80.